home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 7 / Apprentice-Release7.iso / Source Code / C / Applications / Tcl-Tk 8.0 / Pre-installed version / tcl8.0 / tests / socket.test < prev    next >
Encoding:
Text File  |  1997-08-15  |  34.0 KB  |  1,345 lines  |  [TEXT/ALFA]
  1. # Commands tested in this file: socket.
  2. #
  3. # This file contains a collection of tests for one or more of the Tcl
  4. # built-in commands.  Sourcing this file into Tcl runs the tests and
  5. # generates output for errors.  No output means no errors were found.
  6. #
  7. # Copyright (c) 1994-1996 Sun Microsystems, Inc.
  8. #
  9. # See the file "license.terms" for information on usage and redistribution
  10. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  11. #
  12. # Running socket tests with a remote server:
  13. # ------------------------------------------
  14. # 
  15. # Some tests in socket.test depend on the existence of a remote server to
  16. # which they connect. The remote server must be an instance of tcltest and it
  17. # must run the script found in the file "remote.tcl" in this directory. You
  18. # can start the remote server on any machine reachable from the machine on
  19. # which you want to run the socket tests, by issuing:
  20. # 
  21. #     tcltest remote.tcl -port 2048    # Or choose another port number.
  22. # 
  23. # If the machine you are running the remote server on has several IP
  24. # interfaces, you can choose which interface the server listens on for
  25. # connections by specifying the -address command line flag, so:
  26. # 
  27. #     tcltest remote.tcl -address your.machine.com
  28. # 
  29. # These options can also be set by environment variables. On Unix, you can
  30. # type these commands to the shell from which the remote server is started:
  31. # 
  32. #     shell% setenv serverPort 2048
  33. #     shell% setenv serverAddress your.machine.com
  34. # 
  35. # and subsequently you can start the remote server with:
  36. # 
  37. #     tcltest remote.tcl
  38. # 
  39. # to have it listen on port 2048 on the interface your.machine.com.
  40. #     
  41. # When the server starts, it prints out a detailed message containing its
  42. # configuration information, and it will block until killed with a Ctrl-C.
  43. # Once the remote server exists, you can run the tests in socket.test with
  44. # the server by setting two Tcl variables:
  45. # 
  46. #     % set remoteServerIP <name or address of machine on which server runs>
  47. #     % set remoteServerPort 2048
  48. # 
  49. # These variables are also settable from the environment. On Unix, you can:
  50. # 
  51. #     shell% setenv remoteServerIP machine.where.server.runs
  52. #     shell% senetv remoteServerPort 2048
  53. # 
  54. # The preamble of the socket.test file checks to see if the variables are set
  55. # either in Tcl or in the environment; if they are, it attempts to connect to
  56. # the server. If the connection is successful, the tests using the remote
  57. # server will be performed; otherwise, it will attempt to start the remote
  58. # server (via exec) on platforms that support this, on the local host,
  59. # listening at port 2048. If all fails, a message is printed and the tests
  60. # using the remote server are not performed.
  61. #
  62. # SCCS: @(#) socket.test 1.82 97/08/05 13:30:55
  63.  
  64. if {[string compare test [info procs test]] == 1} then {source defs}
  65.  
  66. if {$testConfig(socket) == 0} {
  67.     return
  68. }
  69.  
  70. #
  71. # If remoteServerIP or remoteServerPort are not set, check in the
  72. # environment variables for externally set values.
  73. #
  74.  
  75. if {![info exists remoteServerIP]} {
  76.     if {[info exists env(remoteServerIP)]} {
  77.     set remoteServerIP $env(remoteServerIP)
  78.     }
  79. }
  80. if {![info exists remoteServerPort]} {
  81.     if {[info exists env(remoteServerIP)]} {
  82.     set remoteServerPort $env(remoteServerPort)
  83.     } else {
  84.         if {[info exists remoteServerIP]} {
  85.         set remoteServerPort 2048
  86.         }
  87.     }
  88. }
  89.  
  90. #
  91. # Check if we're supposed to do tests against the remote server
  92. #
  93.  
  94. set doTestsWithRemoteServer 1
  95. if {![info exists remoteServerIP] && ($tcl_platform(platform) != "macintosh")} {
  96.     set remoteServerIP localhost
  97. }
  98. if {($doTestsWithRemoteServer == 1) && (![info exists remoteServerPort])} {
  99.     set remoteServerPort 2048
  100. }
  101.  
  102. # Attempt to connect to a remote server if one is already running. If it
  103. # is not running or for some other reason the connect fails, attempt to
  104. # start the remote server on the local host listening on port 2048. This
  105. # is only done on platforms that support exec (i.e. not on the Mac). On
  106. # platforms that do not support exec, the remote server must be started
  107. # by the user before running the tests.
  108.  
  109. set remoteProcChan ""
  110. set commandSocket ""
  111. if {$doTestsWithRemoteServer} {
  112.     catch {close $commandSocket}
  113.     if {[catch {set commandSocket [socket $remoteServerIP \
  114.                         $remoteServerPort]}] != 0} {
  115.     if {[info commands exec] == ""} {
  116.         set noRemoteTestReason "can't exec"
  117.         set doTestsWithRemoteServer 0
  118.     } elseif {$testConfig(win32s)} {
  119.         set noRemoteTestReason "\ncan't run multiple instances of tcltest under win32s."
  120.         set doTestsWithRemoteServer 0
  121.     } else {
  122.         set remoteServerIP localhost
  123.         if {[catch {set remoteProcChan \
  124.                 [open "|[list $tcltest remote.tcl \
  125.                     -serverIsSilent \
  126.                     -port $remoteServerPort \
  127.                     -address $remoteServerIP]" \
  128.                     w+]} \
  129.            msg] == 0} {
  130.         after 1000
  131.         if {[catch {set commandSocket [socket $remoteServerIP \
  132.                 $remoteServerPort]} msg] == 0} {
  133.             fconfigure $commandSocket -translation crlf -buffering line
  134.         } else {
  135.             set noRemoteTestReason $msg
  136.             set doTestsWithRemoteServer 0
  137.         }
  138.         } else {
  139.         set noRemoteTestReason "$msg $tcltest"
  140.         set doTestsWithRemoteServer 0
  141.         }
  142.     }
  143.     } else {
  144.     fconfigure $commandSocket -translation crlf -buffering line
  145.     }
  146. }
  147.  
  148. if {$doTestsWithRemoteServer == 0} {
  149.     puts "Skipping tests with remote server. See tests/socket.test for"
  150.     puts "information on how to run remote server."
  151.     if {[info exists VERBOSE] && ($VERBOSE != 0)} {
  152.     puts "Reason for not doing remote tests: $noRemoteTestReason"
  153.     }
  154. }
  155.  
  156. #
  157. # If we do the tests, define a command to send a command to the
  158. # remote server.
  159. #
  160.  
  161. if {$doTestsWithRemoteServer == 1} {
  162.     proc sendCommand {c} {
  163.     global commandSocket
  164.  
  165.     if {[eof $commandSocket]} {
  166.         error "remote server disappeared"
  167.     }
  168.  
  169.     if {[catch {puts $commandSocket $c} msg]} {
  170.         error "remote server disappaered: $msg"
  171.     }
  172.     if {[catch {puts $commandSocket "--Marker--Marker--Marker--"} msg]} {
  173.         error "remote server disappeared: $msg"
  174.     }
  175.  
  176.     set resp ""
  177.     while {1} {
  178.         set line [gets $commandSocket]
  179.         if {[eof $commandSocket]} {
  180.         error "remote server disappaered"
  181.         }
  182.         if {[string compare $line "--Marker--Marker--Marker--"] == 0} {
  183.         if {[string compare [lindex $resp 0] error] == 0} {
  184.             error [lindex $resp 1]
  185.         } else {
  186.             return [lindex $resp 1]
  187.         }
  188.         } else {
  189.         append resp $line "\n"
  190.         }
  191.     }
  192.     }
  193. }
  194.  
  195. test socket-1.1 {arg parsing for socket command} {
  196.     list [catch {socket -server} msg] $msg
  197. } {1 {no argument given for -server option}}
  198. test socket-1.2 {arg parsing for socket command} {
  199.     list [catch {socket -server foo} msg] $msg
  200. } {1 {wrong # args: should be either:
  201. socket ?-myaddr addr? ?-myport myport? ?-async? host port
  202. socket -server command ?-myaddr addr? port}}
  203. test socket-1.3 {arg parsing for socket command} {
  204.     list [catch {socket -myaddr} msg] $msg
  205. } {1 {no argument given for -myaddr option}}
  206. test socket-1.4 {arg parsing for socket command} {
  207.     list [catch {socket -myaddr 127.0.0.1} msg] $msg
  208. } {1 {wrong # args: should be either:
  209. socket ?-myaddr addr? ?-myport myport? ?-async? host port
  210. socket -server command ?-myaddr addr? port}}
  211. test socket-1.5 {arg parsing for socket command} {
  212.     list [catch {socket -myport} msg] $msg
  213. } {1 {no argument given for -myport option}}
  214. test socket-1.6 {arg parsing for socket command} {
  215.     list [catch {socket -myport xxxx} msg] $msg
  216. } {1 {expected integer but got "xxxx"}}
  217. test socket-1.7 {arg parsing for socket command} {
  218.     list [catch {socket -myport 2522} msg] $msg
  219. } {1 {wrong # args: should be either:
  220. socket ?-myaddr addr? ?-myport myport? ?-async? host port
  221. socket -server command ?-myaddr addr? port}}
  222. test socket-1.8 {arg parsing for socket command} {
  223.     list [catch {socket -froboz} msg] $msg
  224. } {1 {bad option "-froboz", must be -async, -myaddr, -myport, or -server}}
  225. test socket-1.9 {arg parsing for socket command} {
  226.     list [catch {socket -server foo -myport 2521 3333} msg] $msg
  227. } {1 {Option -myport is not valid for servers}}
  228. test socket-1.10 {arg parsing for socket command} {
  229.     list [catch {socket host 2528 -junk} msg] $msg
  230. } {1 {wrong # args: should be either:
  231. socket ?-myaddr addr? ?-myport myport? ?-async? host port
  232. socket -server command ?-myaddr addr? port}}
  233. test socket-1.11 {arg parsing for socket command} {
  234.     list [catch {socket -server callback 2520 --} msg] $msg
  235. } {1 {wrong # args: should be either:
  236. socket ?-myaddr addr? ?-myport myport? ?-async? host port
  237. socket -server command ?-myaddr addr? port}}
  238. test socket-1.12 {arg parsing for socket command} {
  239.     list [catch {socket foo badport} msg] $msg
  240. } {1 {expected integer but got "badport"}}
  241.  
  242. test socket-2.1 {tcp connection} {stdio} {
  243.     removeFile script
  244.     set f [open script w]
  245.     puts $f {
  246.     set timer [after 2000 "set x timed_out"]
  247.     set f [socket -server accept 2828]
  248.     proc accept {file addr port} {
  249.         global x
  250.         set x done
  251.             close $file
  252.     }
  253.     puts ready
  254.     vwait x
  255.     after cancel $timer
  256.     close $f
  257.     puts $x
  258.     }
  259.     close $f
  260.     set f [open "|[list $tcltest script]" r]
  261.     gets $f x
  262.     if {[catch {socket localhost 2828} msg]} {
  263.         set x $msg
  264.     } else {
  265.         lappend x [gets $f]
  266.         close $msg
  267.     }
  268.     lappend x [gets $f]
  269.     close $f
  270.     set x
  271. } {ready done {}}
  272.  
  273. if [info exists port] {
  274.     incr port
  275. } else { 
  276.     set port [expr 2048 + [pid]%1024]
  277. }
  278. test socket-2.2 {tcp connection with client port specified} {stdio} {
  279.     removeFile script
  280.     set f [open script w]
  281.     puts $f {
  282.     set timer [after 2000 "set x done"]
  283.         set f [socket -server accept 2828]
  284.     proc accept {file addr port} {
  285.             global x
  286.             puts "[gets $file] $port"
  287.             close $file
  288.             set x done
  289.     }
  290.     puts ready
  291.     vwait x
  292.     after cancel $timer
  293.     close $f
  294.     }
  295.     close $f
  296.     set f [open "|[list $tcltest script]" r]
  297.     gets $f x
  298.     global port
  299.     if {[catch {socket -myport $port localhost 2828} sock]} {
  300.         set x $sock
  301.     close [socket localhost 2828]
  302.     puts stderr $sock
  303.     } else {
  304.         puts $sock hello
  305.     flush $sock
  306.         lappend x [gets $f]
  307.         close $sock
  308.     }
  309.     close $f
  310.     set x
  311. } [list ready "hello $port"]
  312. test socket-2.3 {tcp connection with client interface specified} {stdio} {
  313.     removeFile script
  314.     set f [open script w]
  315.     puts $f {
  316.     set timer [after 2000 "set x done"]
  317.         set f [socket  -server accept 2828]
  318.     proc accept {file addr port} {
  319.             global x
  320.             puts "[gets $file] $addr"
  321.             close $file
  322.             set x done
  323.     }
  324.     puts ready
  325.     vwait x
  326.     after cancel $timer
  327.     close $f
  328.     }
  329.     close $f
  330.     set f [open "|[list $tcltest script]" r]
  331.     gets $f x
  332.     if {[catch {socket -myaddr localhost localhost 2828} sock]} {
  333.         set x $sock
  334.     } else {
  335.         puts $sock hello
  336.     flush $sock
  337.         lappend x [gets $f]
  338.         close $sock
  339.     }
  340.     close $f
  341.     set x
  342. } {ready {hello 127.0.0.1}}
  343. test socket-2.4 {tcp connection with server interface specified} {stdio} {
  344.     removeFile script
  345.     set f [open script w]
  346.     puts $f {
  347.     set timer [after 2000 "set x done"]
  348.         set f [socket -server accept -myaddr [info hostname] 2828]
  349.     proc accept {file addr port} {
  350.             global x
  351.             puts "[gets $file]"
  352.             close $file
  353.             set x done
  354.     }
  355.     puts ready
  356.     vwait x
  357.     after cancel $timer
  358.     close $f
  359.     }
  360.     close $f
  361.     set f [open "|[list $tcltest script]" r]
  362.     gets $f x
  363.     if {[catch {socket [info hostname] 2828} sock]} {
  364.         set x $sock
  365.     } else {
  366.         puts $sock hello
  367.     flush $sock
  368.         lappend x [gets $f]
  369.         close $sock
  370.     }
  371.     close $f
  372.     set x
  373. } {ready hello}
  374. test socket-2.5 {tcp connection with redundant server port} {stdio} {
  375.     removeFile script
  376.     set f [open script w]
  377.     puts $f {
  378.     set timer [after 2000 "set x done"]
  379.         set f [socket -server accept 2828]
  380.     proc accept {file addr port} {
  381.             global x
  382.             puts "[gets $file]"
  383.             close $file
  384.             set x done
  385.     }
  386.     puts ready
  387.     vwait x
  388.     after cancel $timer
  389.     close $f
  390.     }
  391.     close $f
  392.     set f [open "|[list $tcltest script]" r]
  393.     gets $f x
  394.     if {[catch {socket localhost 2828} sock]} {
  395.         set x $sock
  396.     } else {
  397.         puts $sock hello
  398.     flush $sock
  399.         lappend x [gets $f]
  400.         close $sock
  401.     }
  402.     close $f
  403.     set x
  404. } {ready hello}
  405. test socket-2.6 {tcp connection} {unixOrPc} {
  406.     set status ok
  407.     if {![catch {set sock [socket localhost 2828]}]} {
  408.     if {![catch {gets $sock}]} {
  409.         set status broken
  410.     }
  411.     close $sock
  412.     }
  413.     set status
  414. } ok
  415. test socket-2.7 {echo server, one line} {stdio} {
  416.     removeFile script
  417.     set f [open script w]
  418.     puts $f {
  419.     set timer [after 2000 "set x done"]
  420.     set f [socket -server accept 2828]
  421.     proc accept {s a p} {
  422.             fileevent $s readable [list echo $s]
  423.         fconfigure $s -translation lf -buffering line
  424.         }
  425.     proc echo {s} {
  426.          set l [gets $s]
  427.              if {[eof $s]} {
  428.                  global x
  429.                  close $s
  430.                  set x done
  431.              } else {
  432.                  puts $s $l
  433.              }
  434.     }
  435.     puts ready
  436.     vwait x
  437.     after cancel $timer
  438.     close $f
  439.     puts done
  440.     }
  441.     close $f
  442.     set f [open "|[list $tcltest script]" r]
  443.     gets $f
  444.     set s [socket localhost 2828]
  445.     fconfigure $s -buffering line -translation lf
  446.     puts $s "hello abcdefghijklmnop"
  447.     set x [gets $s]
  448.     close $s
  449.     set y [gets $f]
  450.     close $f
  451.     list $x $y
  452. } {{hello abcdefghijklmnop} done}
  453. test socket-2.8 {echo server, loop 50 times, single connection} {stdio} {
  454.     removeFile script
  455.     set f [open script w]
  456.     puts $f {
  457.     set f [socket -server accept 2828]
  458.     proc accept {s a p} {
  459.             fileevent $s readable [list echo $s]
  460.             fconfigure $s -buffering line
  461.         }
  462.     proc echo {s} {
  463.          global i
  464.              set l [gets $s]
  465.              if {[eof $s]} {
  466.                  global x
  467.                  close $s
  468.                  set x done
  469.              } else { 
  470.              incr i
  471.                  puts $s $l
  472.              }
  473.     }
  474.     set i 0
  475.     puts ready
  476.     set timer [after 20000 "set x done"]
  477.     vwait x
  478.     after cancel $timer
  479.     close $f
  480.     puts "done $i"
  481.     }
  482.     close $f
  483.     set f [open "|[list $tcltest script]" r]
  484.     gets $f
  485.     set s [socket localhost 2828]
  486.     fconfigure $s -buffering line
  487.     for {set x 0} {$x < 50} {incr x} {
  488.         puts $s "hello abcdefghijklmnop"
  489.         gets $s
  490.     }
  491.     close $s
  492.     set x [gets $f]
  493.     close $f
  494.     set x
  495. } {done 50}
  496. test socket-2.9 {socket conflict} {stdio} {
  497.     set s [socket -server accept 2828]
  498.     removeFile script
  499.     set f [open script w]
  500.     puts $f {set f [socket -server accept 2828]}
  501.     close $f
  502.     set f [open "|[list $tcltest script]" r]
  503.     gets $f
  504.     after 100
  505.     set x [list [catch {close $f} msg] $msg]
  506.     close $s
  507.     set x
  508. } {1 {couldn't open socket: address already in use
  509.     while executing
  510. "socket -server accept 2828"
  511.     (file "script" line 1)}}
  512. test socket-2.10 {close on accept, accepted socket lives} {
  513.     set done 0
  514.     set timer [after 20000 "set done timed_out"]
  515.     set ss [socket -server accept 2830]
  516.     proc accept {s a p} {
  517.     global ss
  518.     close $ss
  519.     fileevent $s readable "readit $s"
  520.     fconfigure $s -trans lf
  521.     }
  522.     proc readit {s} {
  523.     global done
  524.     gets $s
  525.     close $s
  526.     set done 1
  527.     }
  528.     set cs [socket [info hostname] 2830]
  529.     puts $cs hello
  530.     close $cs
  531.     vwait done
  532.     after cancel $timer
  533.     set done
  534. } 1
  535.  
  536. test socket-3.1 {socket conflict} {stdio} {
  537.     removeFile script
  538.     set f [open script w]
  539.     puts $f {
  540.     set f [socket -server accept 2828]
  541.     puts ready
  542.     gets stdin
  543.     close $f
  544.     }
  545.     close $f
  546.     set f [open "|[list $tcltest script]" r+]
  547.     gets $f
  548.     set x [list [catch {socket -server accept 2828} msg] \
  549.         $msg]
  550.     puts $f bye
  551.     close $f
  552.     set x
  553. } {1 {couldn't open socket: address already in use}}
  554. test socket-3.2 {server with several clients} {stdio} {
  555.     removeFile script
  556.     set f [open script w]
  557.     puts $f {
  558.     set t1 [after 30000 "set x timed_out"]
  559.     set t2 [after 31000 "set x timed_out"]
  560.     set t3 [after 32000 "set x timed_out"]
  561.     set counter 0
  562.     set s [socket -server accept 2828]
  563.     proc accept {s a p} {
  564.         fileevent $s readable [list echo $s]
  565.         fconfigure $s -buffering line
  566.     }
  567.     proc echo {s} {
  568.          global x
  569.              set l [gets $s]
  570.              if {[eof $s]} {
  571.                  close $s
  572.                  set x done
  573.              } else {
  574.                  puts $s $l
  575.              }
  576.     }
  577.     puts ready
  578.     vwait x
  579.     after cancel $t1
  580.     vwait x
  581.     after cancel $t2
  582.     vwait x
  583.     after cancel $t3
  584.     close $s
  585.     puts $x
  586.     }
  587.     close $f
  588.     set f [open "|[list $tcltest script]" r+]
  589.     set x [gets $f]
  590.     set s1 [socket localhost 2828]
  591.     fconfigure $s1 -buffering line
  592.     set s2 [socket localhost 2828]
  593.     fconfigure $s2 -buffering line
  594.     set s3 [socket localhost 2828]
  595.     fconfigure $s3 -buffering line
  596.     for {set i 0} {$i < 100} {incr i} {
  597.     puts $s1 hello,s1
  598.     gets $s1
  599.     puts $s2 hello,s2
  600.     gets $s2
  601.     puts $s3 hello,s3
  602.     gets $s3
  603.     }
  604.     close $s1
  605.     close $s2
  606.     close $s3
  607.     lappend x [gets $f]
  608.     close $f
  609.     set x
  610. } {ready done}
  611.  
  612. test socket-4.1 {server with several clients} {stdio} {
  613.     removeFile script
  614.     set f [open script w]
  615.     puts $f {
  616.     gets stdin
  617.     set s [socket localhost 2828]
  618.     fconfigure $s -buffering line
  619.     for {set i 0} {$i < 100} {incr i} {
  620.         puts $s hello
  621.         gets $s
  622.     }
  623.     close $s
  624.     puts bye
  625.     gets stdin
  626.     }
  627.     close $f
  628.     set p1 [open "|[list $tcltest script]" r+]
  629.     fconfigure $p1 -buffering line
  630.     set p2 [open "|[list $tcltest script]" r+]
  631.     fconfigure $p2 -buffering line
  632.     set p3 [open "|[list $tcltest script]" r+]
  633.     fconfigure $p3 -buffering line
  634.     proc accept {s a p} {
  635.     fconfigure $s -buffering line
  636.     fileevent $s readable [list echo $s]
  637.     }
  638.     proc echo {s} {
  639.     global x
  640.         set l [gets $s]
  641.         if {[eof $s]} {
  642.             close $s
  643.             set x done
  644.         } else {
  645.             puts $s $l
  646.         }
  647.     }
  648.     set t1 [after 30000 "set x timed_out"]
  649.     set t2 [after 31000 "set x timed_out"]
  650.     set t3 [after 32000 "set x timed_out"]
  651.     set s [socket -server accept 2828]
  652.     puts $p1 open
  653.     puts $p2 open
  654.     puts $p3 open
  655.     vwait x
  656.     vwait x
  657.     vwait x
  658.     after cancel $t1
  659.     after cancel $t2
  660.     after cancel $t3
  661.     close $s
  662.     set l ""
  663.     lappend l [list p1 [gets $p1] $x]
  664.     lappend l [list p2 [gets $p2] $x]
  665.     lappend l [list p3 [gets $p3] $x]
  666.     puts $p1 bye
  667.     puts $p2 bye
  668.     puts $p3 bye
  669.     close $p1
  670.     close $p2
  671.     close $p3
  672.     set l
  673. } {{p1 bye done} {p2 bye done} {p3 bye done}}
  674. test socket-4.2 {byte order problems, socket numbers, htons} {
  675.     set x ok
  676.     if {[catch {socket -server dodo 0x3000} msg]} {
  677.     set x $msg
  678.     } else {
  679.     close $msg
  680.     }
  681.     set x
  682. } ok
  683.  
  684. test socket-5.1 {byte order problems, socket numbers, htons} {unixOnly} {
  685.     #
  686.     # THIS TEST WILL FAIL if you are running as superuser.
  687.     #
  688.     set x {couldn't open socket: not owner}
  689.     if {![catch {socket -server dodo 0x1} msg]} {
  690.         set x {htons problem, should be disallowed, are you running as SU?}
  691.     close $msg
  692.     }
  693.     set x
  694. } {couldn't open socket: not owner}
  695. test socket-5.2 {byte order problems, socket numbers, htons} {
  696.     set x {couldn't open socket: port number too high}
  697.     if {![catch {socket -server dodo 0x10000} msg]} {
  698.     set x {port resolution problem, should be disallowed}
  699.     close $msg
  700.     }
  701.     set x
  702. } {couldn't open socket: port number too high}
  703. test socket-5.3 {byte order problems, socket numbers, htons} {unixOnly} {
  704.     #
  705.     # THIS TEST WILL FAIL if you are running as superuser.
  706.     #
  707.     set x {couldn't open socket: not owner}
  708.     if {![catch {socket -server dodo 21} msg]} {
  709.     set x {htons problem, should be disallowed, are you running as SU?}
  710.     close $msg
  711.     }
  712.     set x
  713. } {couldn't open socket: not owner}
  714.  
  715. test socket-6.1 {accept callback error} {stdio} {
  716.     removeFile script
  717.     set f [open script w]
  718.     puts $f {
  719.     gets stdin
  720.     socket localhost 2848
  721.     }
  722.     close $f
  723.     set f [open "|[list $tcltest script]" r+]
  724.     proc bgerror args {
  725.     global x
  726.     set x $args
  727.     }
  728.     proc accept {s a p} {expr 10 / 0}
  729.     set s [socket -server accept 2848]
  730.     puts $f hello
  731.     close $f
  732.     set timer [after 10000 "set x timed_out"]
  733.     vwait x
  734.     after cancel $timer
  735.     close $s
  736.     rename bgerror {}
  737.     set x
  738. } {{divide by zero}}
  739.  
  740. test socket-7.1 {testing socket specific options} {stdio} {
  741.     removeFile script
  742.     set f [open script w]
  743.     puts $f {
  744.     socket -server accept 2820
  745.     proc accept args {
  746.         global x
  747.         set x done
  748.     }
  749.     puts ready
  750.     set timer [after 10000 "set x timed_out"]
  751.     vwait x
  752.     after cancel $timer
  753.     }
  754.     close $f
  755.     set f [open "|[list $tcltest script]" r]
  756.     gets $f
  757.     set s [socket localhost 2820]
  758.     set p [fconfigure $s -peername]
  759.     close $s
  760.     close $f
  761.     set l ""
  762.     lappend l [string compare [lindex $p 0] 127.0.0.1]
  763.     lappend l [string compare [lindex $p 2] 2820]
  764.     lappend l [llength $p]
  765. } {0 0 3}
  766. test socket-7.2 {testing socket specific options} {stdio} {
  767.     removeFile script
  768.     set f [open script w]
  769.     puts $f {
  770.     socket -server accept 2821
  771.     proc accept args {
  772.         global x
  773.         set x done
  774.     }
  775.     puts ready
  776.     set timer [after 10000 "set x timed_out"]
  777.     vwait x
  778.     after cancel $timer
  779.     }
  780.     close $f
  781.     set f [open "|[list $tcltest script]" r]
  782.     gets $f
  783.     set s [socket localhost 2821]
  784.     set p [fconfigure $s -sockname]
  785.     close $s
  786.     close $f
  787.     set l ""
  788.     lappend l [llength $p]
  789.     lappend l [lindex $p 0]
  790.     lappend l [expr [lindex $p 2] == 2821]
  791. } {3 127.0.0.1 0}
  792. test socket-7.3 {testing socket specific options} {
  793.     set s [socket -server accept 2822]
  794.     set l [fconfigure $s]
  795.     close $s
  796.     update
  797.     llength $l
  798. } 10
  799. test socket-7.4 {testing socket specific options} {
  800.     set s [socket -server accept 2823]
  801.     proc accept {s a p} {
  802.     global x
  803.     set x [fconfigure $s -sockname]
  804.     close $s
  805.     }
  806.     set s1 [socket [info hostname] 2823]
  807.     set timer [after 10000 "set x timed_out"]
  808.     vwait x
  809.     after cancel $timer
  810.     close $s
  811.     close $s1
  812.     set l ""
  813.     lappend l [lindex $x 2] [llength $x]
  814. } {2823 3}
  815. test socket-7.5 {testing socket specific options} {unixOrPc} {
  816.     set s [socket -server accept 2829]
  817.     proc accept {s a p} {
  818.     global x
  819.     set x [fconfigure $s -sockname]
  820.     close $s
  821.     }
  822.     set s1 [socket localhost 2829]
  823.     set timer [after 10000 "set x timed_out"]
  824.     vwait x
  825.     after cancel $timer
  826.     close $s
  827.     close $s1
  828.     set l ""
  829.     lappend l [lindex $x 0] [lindex $x 2] [llength $x]
  830. } {127.0.0.1 2829 3}
  831.  
  832. test socket-8.1 {testing -async flag on sockets} {
  833.     # NOTE: This test may fail on some Solaris 2.4 systems. If it does,
  834.     # check that you have these patches installed (using showrev -p):
  835.     #
  836.     # 101907-05, 101925-02, 101945-14, 101959-03, 101969-05, 101973-03,
  837.     # 101977-03, 101981-02, 101985-01, 102001-03, 102003-01, 102007-01,
  838.     # 102011-02, 102024-01, 102039-01, 102044-01, 102048-01, 102062-03,
  839.     # 102066-04, 102070-01, 102105-01, 102153-03, 102216-01, 102232-01,
  840.     # 101878-03, 101879-01, 101880-03, 101933-01, 101950-01, 102030-01,
  841.     # 102057-08, 102140-01, 101920-02, 101921-09, 101922-07, 101923-03
  842.     #
  843.     # If after installing these patches you are still experiencing a
  844.     # problem, please email jyl@eng.sun.com. We have not observed this
  845.     # failure on Solaris 2.5, so another option (instead of installing
  846.     # these patches) is to upgrade to Solaris 2.5.
  847.     set s [socket -server accept 2830]
  848.     proc accept {s a p} {
  849.     global x
  850.     puts $s bye
  851.     close $s
  852.     set x done
  853.     }
  854.     set s1 [socket -async [info hostname] 2830]
  855.     vwait x
  856.     set z [gets $s1]
  857.     close $s
  858.     close $s1
  859.     set z
  860. } bye
  861.  
  862. test socket-9.1 {testing spurious events} {
  863.     set len 0
  864.     set spurious 0
  865.     set done 0
  866.     proc readlittle {s} {
  867.     global spurious done len
  868.     set l [read $s 1]
  869.     if {[string length $l] == 0} {
  870.         if {![eof $s]} {
  871.         incr spurious
  872.         } else {
  873.         close $s
  874.         set done 1
  875.         }
  876.     } else {
  877.         incr len [string length $l]
  878.     }
  879.     }
  880.     proc accept {s a p} {
  881.     fconfigure $s -buffering none -blocking off
  882.     fileevent $s readable [list readlittle $s]
  883.     }
  884.     set s [socket -server accept 2831]
  885.     set c [socket [info hostname] 2831]
  886.     puts -nonewline $c 01234567890123456789012345678901234567890123456789
  887.     close $c
  888.     set timer [after 10000 "set done timed_out"]
  889.     vwait done
  890.     after cancel $timer
  891.     close $s
  892.     list $spurious $len
  893. } {0 50}
  894. test socket-9.2 {testing async write, fileevents, flush on close} {tempNotMac} {
  895.     set firstblock ""
  896.     for {set i 0} {$i < 5} {incr i} {set firstblock "a$firstblock$firstblock"}
  897.     set secondblock ""
  898.     for {set i 0} {$i < 16} {incr i} {
  899.     set secondblock "b$secondblock$secondblock"
  900.     }
  901.     set l [socket -server accept 2832]
  902.     proc accept {s a p} {
  903.     fconfigure $s -blocking 0 -translation lf -buffersize 16384 \
  904.         -buffering line
  905.     fileevent $s readable "readable $s"
  906.     }
  907.     proc readable {s} {
  908.     set l [gets $s]
  909.     fileevent $s readable {}
  910.     after 1000 respond $s
  911.     }
  912.     proc respond {s} {
  913.     global firstblock
  914.     puts -nonewline $s $firstblock
  915.     after 1000 writedata $s
  916.     }
  917.     proc writedata {s} {
  918.     global secondblock
  919.     puts -nonewline $s $secondblock
  920.     close $s
  921.     }
  922.     set s [socket [info hostname] 2832]
  923.     fconfigure $s -blocking 0 -trans lf -buffering line
  924.     set count 0
  925.     puts $s hello
  926.     proc readit {s} {
  927.     global count done
  928.     set l [read $s]
  929.     incr count [string length $l]
  930.     if {[eof $s]} {
  931.         close $s
  932.         set done 1
  933.     }
  934.     }
  935.     fileevent $s readable "readit $s"
  936.     set timer [after 10000 "set done timed_out"]
  937.     vwait done
  938.     after cancel $timer
  939.     close $l
  940.     set count
  941. } 65566
  942. test socket-9.3 {testing EOF stickyness} {
  943.     proc count_to_eof {s} {
  944.     global count done timer
  945.     set l [gets $s]
  946.     if {[eof $s]} {
  947.         incr count
  948.         if {$count > 9} {
  949.         close $s
  950.         set done true
  951.         set count {eof is sticky}
  952.         after cancel $timer
  953.         }
  954.     }
  955.     }
  956.     proc timerproc {} {
  957.     global done count c
  958.     set done true
  959.     set count {timer went off, eof is not sticky}
  960.     close $c
  961.     }    
  962.     set count 0
  963.     set done false
  964.     proc write_then_close {s} {
  965.     puts $s bye
  966.     close $s
  967.     }
  968.     proc accept {s a p} {
  969.     fconfigure $s -buffering line -translation lf
  970.     fileevent $s writable "write_then_close $s"
  971.     }
  972.     set s [socket -server accept 2833]
  973.     set c [socket [info hostname] 2833]
  974.     fconfigure $c -blocking off -buffering line -translation lf
  975.     fileevent $c readable "count_to_eof $c"
  976.     set timer [after 1000 timerproc]
  977.     vwait done
  978.     close $s
  979.     set count
  980. } {eof is sticky}
  981.  
  982. removeFile script
  983.  
  984. #
  985. # The rest of the tests are run only if we are doing testing against
  986. # a remote server.
  987. #
  988.  
  989. if {$doTestsWithRemoteServer == 0} {
  990.     return
  991. }
  992.  
  993. test socket-10.1 {tcp connection} {
  994.     sendCommand {
  995.     set socket9_1_test_server [socket -server accept 2834]
  996.     proc accept {s a p} {
  997.         puts $s done
  998.         close $s
  999.     }
  1000.     }
  1001.     set s [socket $remoteServerIP 2834]
  1002.     set r [gets $s]
  1003.     close $s
  1004.     sendCommand {close $socket9_1_test_server}
  1005.     set r
  1006. } done
  1007. test socket-10.2 {client specifies its port} {
  1008.     if {[info exists port]} {
  1009.     incr port
  1010.     } else {
  1011.     set port [expr 2048 + [pid]%1024]
  1012.     }
  1013.     sendCommand {
  1014.     set socket9_2_test_server [socket -server accept 2835]
  1015.     proc accept {s a p} {
  1016.         puts $s $p
  1017.         close $s
  1018.     }
  1019.     }
  1020.     set s [socket -myport $port $remoteServerIP 2835]
  1021.     set r [gets $s]
  1022.     close $s
  1023.     sendCommand {close $socket9_2_test_server}
  1024.     if {$r == $port} {
  1025.     set result ok
  1026.     } else {
  1027.     set result broken
  1028.     }
  1029.     set result
  1030. } ok
  1031. #
  1032. # Tests io-10.3, io-10.4 have been removed.
  1033. #
  1034. test socket-10.3 {trying to connect, no server} {
  1035.     set status ok
  1036.     if {![catch {set s [socket $remoteServerIp 2836]}]} {
  1037.     if {![catch {gets $s}]} {
  1038.         set status broken
  1039.     }
  1040.     close $s
  1041.     }
  1042.     set status
  1043. } ok
  1044. test socket-10.4 {remote echo, one line} {
  1045.     sendCommand {
  1046.     set socket10_6_test_server [socket -server accept 2836]
  1047.     proc accept {s a p} {
  1048.         fileevent $s readable [list echo $s]
  1049.         fconfigure $s -buffering line -translation crlf
  1050.     }
  1051.     proc echo {s} {
  1052.         set l [gets $s]
  1053.         if {[eof $s]} {
  1054.         close $s
  1055.         } else {
  1056.         puts $s $l
  1057.         }
  1058.     }
  1059.     }
  1060.     set f [socket $remoteServerIP 2836]
  1061.     fconfigure $f -translation crlf -buffering line
  1062.     puts $f hello
  1063.     set r [gets $f]
  1064.     close $f
  1065.     sendCommand {close $socket10_6_test_server}
  1066.     set r
  1067. } hello
  1068. test socket-10.5 {remote echo, 50 lines} {
  1069.     sendCommand {
  1070.     set socket10_7_test_server [socket -server accept 2836]
  1071.     proc accept {s a p} {
  1072.         fileevent $s readable [list echo $s]
  1073.         fconfigure $s -buffering line -translation crlf
  1074.     }
  1075.     proc echo {s} {
  1076.         set l [gets $s]
  1077.         if {[eof $s]} {
  1078.         close $s
  1079.         } else {
  1080.         puts $s $l
  1081.         }
  1082.     }
  1083.     }
  1084.     set f [socket $remoteServerIP 2836]
  1085.     fconfigure $f -translation crlf -buffering line
  1086.     for {set cnt 0} {$cnt < 50} {incr cnt} {
  1087.     puts $f "hello, $cnt"
  1088.     if {[string compare [gets $f] "hello, $cnt"] != 0} {
  1089.         break
  1090.     }
  1091.     }
  1092.     close $f
  1093.     sendCommand {close $socket10_7_test_server}
  1094.     set cnt
  1095. } 50
  1096. # Macintosh sockets can have more than one server per port
  1097. if {$tcl_platform(platform) == "macintosh"} {
  1098.     set conflictResult {0 2836}
  1099. } else {
  1100.     set conflictResult {1 {couldn't open socket: address already in use}}
  1101. }
  1102. test socket-10.6 {socket conflict} {
  1103.     set s1 [socket -server accept 2836]
  1104.     if {[catch {set s2 [socket -server accept 2836]} msg]} {
  1105.     set result [list 1 $msg]
  1106.     } else {
  1107.     set result [list 0 [lindex [fconfigure $s2 -sockname] 2]]
  1108.     close $s2
  1109.     }
  1110.     close $s1
  1111.     set result
  1112. } $conflictResult
  1113. test socket-10.7 {server with several clients} {
  1114.     sendCommand {
  1115.     set socket10_9_test_server [socket -server accept 2836]
  1116.     proc accept {s a p} {
  1117.         fconfigure $s -buffering line
  1118.         fileevent $s readable [list echo $s]
  1119.     }
  1120.     proc echo {s} {
  1121.         set l [gets $s]
  1122.         if {[eof $s]} {
  1123.         close $s
  1124.         } else {
  1125.         puts $s $l
  1126.         }
  1127.     }
  1128.     }
  1129.     set s1 [socket $remoteServerIP 2836]
  1130.     fconfigure $s1 -buffering line
  1131.     set s2 [socket $remoteServerIP 2836]
  1132.     fconfigure $s2 -buffering line
  1133.     set s3 [socket $remoteServerIP 2836]
  1134.     fconfigure $s3 -buffering line
  1135.     for {set i 0} {$i < 100} {incr i} {
  1136.     puts $s1 hello,s1
  1137.     gets $s1
  1138.     puts $s2 hello,s2
  1139.     gets $s2
  1140.     puts $s3 hello,s3
  1141.     gets $s3
  1142.     }
  1143.     close $s1
  1144.     close $s2
  1145.     close $s3
  1146.     sendCommand {close $socket10_9_test_server}
  1147.     set i
  1148. } 100    
  1149. test socket-10.8 {client with several servers} {
  1150.     sendCommand {
  1151.     set s1 [socket -server "accept 4003" 4003]
  1152.     set s2 [socket -server "accept 4004" 4004]
  1153.     set s3 [socket -server "accept 4005" 4005]
  1154.     proc accept {mp s a p} {
  1155.         puts $s $mp
  1156.         close $s
  1157.     }
  1158.     }
  1159.     set s1 [socket $remoteServerIP 4003]
  1160.     set s2 [socket $remoteServerIP 4004]
  1161.     set s3 [socket $remoteServerIP 4005]
  1162.     set l ""
  1163.     lappend l [gets $s1] [gets $s1] [eof $s1] [gets $s2] [gets $s2] [eof $s2] \
  1164.     [gets $s3] [gets $s3] [eof $s3]
  1165.     close $s1
  1166.     close $s2
  1167.     close $s3
  1168.     sendCommand {
  1169.     close $s1
  1170.     close $s2
  1171.     close $s3
  1172.     }
  1173.     set l
  1174. } {4003 {} 1 4004 {} 1 4005 {} 1}
  1175. test socket-10.9 {accept callback error} {
  1176.     set s [socket -server accept 2836]
  1177.     proc accept {s a p} {expr 10 / 0}
  1178.     proc bgerror args {
  1179.     global x
  1180.     set x $args
  1181.     }
  1182.     if {[catch {sendCommand {
  1183.         set peername [fconfigure $callerSocket -peername]
  1184.         set s [socket [lindex $peername 0] 2836]
  1185.         close $s
  1186.          }} msg]} {
  1187.     close $s
  1188.     error $msg
  1189.     }
  1190.     set timer [after 10000 "set x timed_out"]
  1191.     vwait x
  1192.     after cancel $timer
  1193.     close $s
  1194.     rename bgerror {}
  1195.     set x
  1196. } {{divide by zero}}
  1197. test socket-10.10 {testing socket specific options} {
  1198.     sendCommand {
  1199.     set socket10_12_test_server [socket -server accept 2836]
  1200.     proc accept {s a p} {close $s}
  1201.     }
  1202.     set s [socket $remoteServerIP 2836]
  1203.     set p [fconfigure $s -peername]
  1204.     set n [fconfigure $s -sockname]
  1205.     set l ""
  1206.     lappend l [lindex $p 2] [llength $p] [llength $p]
  1207.     close $s
  1208.     sendCommand {close $socket10_12_test_server}
  1209.     set l
  1210. } {2836 3 3}
  1211. test socket-10.11 {testing spurious events} {
  1212.     sendCommand {
  1213.     set socket10_13_test_server [socket -server accept 2836]
  1214.     proc accept {s a p} {
  1215.         fconfigure $s -translation "auto lf"
  1216.         after 100 writesome $s
  1217.     }
  1218.     proc writesome {s} {
  1219.         for {set i 0} {$i < 100} {incr i} {
  1220.         puts $s "line $i from remote server"
  1221.         }
  1222.         close $s
  1223.     }
  1224.     }
  1225.     set len 0
  1226.     set spurious 0
  1227.     set done 0
  1228.     proc readlittle {s} {
  1229.     global spurious done len
  1230.     set l [read $s 1]
  1231.     if {[string length $l] == 0} {
  1232.         if {![eof $s]} {
  1233.         incr spurious
  1234.         } else {
  1235.         close $s
  1236.         set done 1
  1237.         }
  1238.     } else {
  1239.         incr len [string length $l]
  1240.     }
  1241.     }
  1242.     set c [socket $remoteServerIP 2836]
  1243.     fileevent $c readable "readlittle $c"
  1244.     set timer [after 10000 "set done timed_out"]
  1245.     vwait done
  1246.     after cancel $timer
  1247.     sendCommand {close $socket10_13_test_server}
  1248.     list $spurious $len
  1249. } {0 2690}
  1250. test socket-10.12 {testing EOF stickyness} {
  1251.     set counter 0
  1252.     set done 0
  1253.     proc count_up {s} {
  1254.     global counter done after_id
  1255.     set l [gets $s]
  1256.     if {[eof $s]} {
  1257.         incr counter
  1258.         if {$counter > 9} {
  1259.         set done {EOF is sticky}
  1260.         after cancel $after_id
  1261.         close $s
  1262.         }
  1263.     }
  1264.     }
  1265.     proc timed_out {} {
  1266.     global c done
  1267.     set done {timed_out, EOF is not sticky}
  1268.     close $c
  1269.     }
  1270.     sendCommand {
  1271.     set socket10_14_test_server [socket -server accept 2836]
  1272.     proc accept {s a p} {
  1273.         after 100 close $s
  1274.     }
  1275.     }
  1276.     set c [socket $remoteServerIP 2836]
  1277.     fileevent $c readable "count_up $c"
  1278.     set after_id [after 1000 timed_out]
  1279.     vwait done
  1280.     sendCommand {close $socket10_14_test_server}
  1281.     set done
  1282. } {EOF is sticky}
  1283. test socket-10.13 {testing async write, async flush, async close} {
  1284.     proc readit {s} {
  1285.     global count done
  1286.     set l [read $s]
  1287.     incr count [string length $l]
  1288.     if {[eof $s]} {
  1289.         close $s
  1290.         set done 1
  1291.     }
  1292.     }
  1293.     sendCommand {
  1294.     set firstblock ""
  1295.     for {set i 0} {$i < 5} {incr i} {
  1296.         set firstblock "a$firstblock$firstblock"
  1297.     }
  1298.     set secondblock ""
  1299.     for {set i 0} {$i < 16} {incr i} {
  1300.         set secondblock "b$secondblock$secondblock"
  1301.     }
  1302.     set l [socket -server accept 2845]
  1303.     proc accept {s a p} {
  1304.         fconfigure $s -blocking 0 -translation lf -buffersize 16384 \
  1305.         -buffering line
  1306.         fileevent $s readable "readable $s"
  1307.     }
  1308.     proc readable {s} {
  1309.         set l [gets $s]
  1310.         fileevent $s readable {}
  1311.         after 1000 respond $s
  1312.     }
  1313.     proc respond {s} {
  1314.         global firstblock
  1315.         puts -nonewline $s $firstblock
  1316.         after 1000 writedata $s
  1317.     }
  1318.     proc writedata {s} {
  1319.         global secondblock
  1320.         puts -nonewline $s $secondblock
  1321.         close $s
  1322.     }
  1323.     }
  1324.     set s [socket $remoteServerIP 2845]
  1325.     fconfigure $s -blocking 0 -trans lf -buffering line
  1326.     set count 0
  1327.     puts $s hello
  1328.     fileevent $s readable "readit $s"
  1329.     set timer [after 10000 "set done timed_out"]
  1330.     vwait done
  1331.     after cancel $timer
  1332.     sendCommand {close $l}
  1333.     set count
  1334. } 65566
  1335.  
  1336. if {[string match sock* $commandSocket] == 1} {
  1337.    puts $commandSocket exit
  1338.    flush $commandSocket
  1339. }
  1340. catch {close $commandSocket}
  1341. catch {close $remoteProcChan}
  1342.  
  1343. set x ""
  1344. unset x
  1345.